Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacHaskell 2.2/progs/prelude/PreludeCore.hs

Text File | 1994-09-27 | 19.3 KB | 705 lines | [TEXT/YHS2]

-- Standard types, classes, and instances

module PreludeCore (
    Eq((==), (/=)),
    Ord((<), (<=), (>=), (>), max, min),
    Num((+), (-), (*), negate, abs, signum, fromInteger),
    Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger),
    Fractional((/), recip, fromRational),
    Floating(pi, exp, log, sqrt, (**), logBase,
         sin, cos, tan, asin, acos, atan,
         sinh, cosh, tanh, asinh, acosh, atanh),
    Real(toRational),
    RealFrac(properFraction, truncate, round, ceiling, floor),
    RealFloat(floatRadix, floatDigits, floatRange,
          encodeFloat, decodeFloat, exponent, significand, scaleFloat,
          atan2),
    Ix(range, index, inRange),
    Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo),
    Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..),
    Binary(readBin, showBin),
--  List type: [_]((:), [])
--  Tuple types: (_,_), (_,_,_), etc.
--  Trivial type: ()
    Bool(True, False),
    Char, Int, Integer, Float, Double, Bin,
    Ratio, Complex((:+)), Array,
    PreludeC.. , PreludeDerivings..,
    String(..), Rational(..) )  where

{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols

import PreludePrims
import PreludeText
import PreludeRatio(Ratio, Rational(..))
import PreludeComplex(Complex((:+)))
import PreludeArray(Array)
--import PreludeIO({-Request, Response,-} IOError,
--         Dialogue(..), SuccCont(..), StrCont(..),
--         StrListCont(..), BinCont(..), FailCont(..))
import PreludeC
import PreludeDerivings

infixr 8  **
infixl 7  *, /, `quot`, `rem`, `div`, `mod`
infixl 6  +, -
infix  4  ==, /=, <, <=, >=, >


infixr 5 :

data Int = MkInt
data Integer = MkInteger
data Float = MkFloat
data Double   = MkDouble
data Char = MkChar
data Bin = MkBin
data List a = a : (List a) | Nil  deriving (Eq, Ord)
{-# ImportLispType (List ((:)("pair?","cons","car","cdr"),
                          Nil("null?","'()"))) #-}


data Arrow a b = MkArrow a b
data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary)

-- Equality and Ordered classes

class  Eq a  where
    (==), (/=)        :: a -> a -> Bool

    x /= y        =  not (x == y)

    {-# (/=) :: Inline #-}


class  (Eq a) => Ord a  where
    (<), (<=), (>=), (>):: a -> a -> Bool
    max, min        :: a -> a -> a

    x <     y        =  x <= y && x /= y
    x >= y        =  y <= x
    x >     y        =  y <    x

    -- The following default methods are appropriate for partial orders.
    -- Note that the second guards in each function can be replaced
    -- by "otherwise" and the error cases, eliminated for total orders.
    max x y | x >= y    =  x
        | y >= x    =  y
        |otherwise    =  error "max{PreludeCore}: no ordering relation"
    min x y | x <= y    =  x
        | y <= x    =  y
        |otherwise    =  error "min{PreludeCore}: no ordering relation"

    {-# (<) :: Inline #-}
    {-# (>=) :: Inline #-}
    {-# (>) :: Inline #-}
    {-# max :: Inline #-}
    {-# min :: Inline #-}



-- Numeric classes

class  (Eq a, Text a) => Num a  where
    (+), (-), (*)    :: a -> a -> a
    negate        :: a -> a
    abs, signum        :: a -> a
    fromInteger        :: Integer -> a

    x - y        =  x + negate y

    {-# (-) :: Inline #-}


class  (Num a, Enum a) => Real a  where
    toRational        ::  a -> Rational

class  (Real a, Ix a) => Integral a  where
    quot, rem, div, mod    :: a -> a -> a
    quotRem, divMod    :: a -> a -> (a,a)
    even, odd        :: a -> Bool
    toInteger        :: a -> Integer

    n `quot` d        =  q  where (q,r) = quotRem n d
    n `rem` d        =  r  where (q,r) = quotRem n d
    n `div` d        =  q  where (q,r) = divMod n d
    n `mod` d        =  r  where (q,r) = divMod n d
    divMod n d         =  if signum r == - signum d then (q-1, r+d) else qr
               where qr@(q,r) = quotRem n d
    even n        =  n `rem` 2 == 0
    odd            =  not . even

    {-# quot :: Inline #-}
    {-# rem  :: Inline #-}
    {-# div  :: Inline #-}
    {-# mod  :: Inline #-}
    {-# divMod :: Inline #-}
    {-# even :: Inline #-}
    {-# odd  :: Inline #-}



class  (Num a) => Fractional a  where
    (/)            :: a -> a -> a
    recip        :: a -> a
    fromRational    :: Rational -> a

    recip x        =  1 / x

    {-# recip  :: Inline #-}

class  (Fractional a) => Floating a  where
    pi            :: a
    exp, log, sqrt    :: a -> a
    (**), logBase    :: a -> a -> a
    sin, cos, tan    :: a -> a
    asin, acos, atan    :: a -> a
    sinh, cosh, tanh    :: a -> a
    asinh, acosh, atanh :: a -> a

    x ** y        =  exp (log x * y)
    logBase x y        =  log y / log x
    sqrt x        =  x ** 0.5
    tan  x        =  sin  x / cos  x
    tanh x        =  sinh x / cosh x



class  (Real a, Fractional a) => RealFrac a  where
    properFraction    :: (Integral b) => a -> (b,a)
    truncate, round    :: (Integral b) => a -> b
    ceiling, floor    :: (Integral b) => a -> b

    truncate x        =  m  where (m,_) = properFraction x

    round x        =  let (n,r) = properFraction x
                       m     = if r < 0 then n - 1 else n + 1
                   in case signum (abs r - 0.5) of
                    -1 -> n
                     0  -> if even n then n else m
                    1  -> m

    ceiling x        =  if r > 0 then n + 1 else n
                   where (n,r) = properFraction x

    floor x        =  if r < 0 then n - 1 else n
                   where (n,r) = properFraction x

class  (RealFrac a, Floating a) => RealFloat a  where
    floatRadix        :: a -> Integer
    floatDigits        :: a -> Int
    floatRange        :: a -> (Int,Int)
    decodeFloat        :: a -> (Integer,Int)
    encodeFloat        :: Integer -> Int -> a
    exponent        :: a -> Int
    significand        :: a -> a
    scaleFloat        :: Int -> a -> a
    atan2               :: a -> a -> a


    exponent x        =  if m == 0 then 0 else n + floatDigits x
               where (m,n) = decodeFloat x

    significand x    =  encodeFloat m (- floatDigits x)
               where (m,_) = decodeFloat x

    scaleFloat k x    =  encodeFloat m (n+k)
               where (m,n) = decodeFloat x

    atan2 y x    =  case (signum y, signum x) of
            ( 0, 1) ->  0
            ( 1, 0) ->  pi/2
            ( 0,-1) ->  pi
            (-1, 0) -> -pi/2
            ( _, 1) ->  atan (y/x)
            ( _,-1) ->  atan (y/x) + pi
            ( 0, 0) ->  error "atan2{Prelude}: atan2 of origin"


-- Index and Enumeration classes

class  (Ord a, Text a) => Ix a  where   -- This is a Yale modification
    range        :: (a,a) -> [a]
    index        :: (a,a) -> a -> Int
    inRange        :: (a,a) -> a -> Bool

indexError :: Text a => a -> a -> a -> b
indexError i m n =
  error ("Index " ++ show i ++ " is outside the range (" ++
                     show m ++ "," ++ show n ++ ")\n")

class  (Ord a) => Enum a    where
    enumFrom        :: a -> [a]        -- [n..]
    enumFromThen    :: a -> a -> [a]    -- [n,n'..]
    enumFromTo        :: a -> a -> [a]    -- [n..m]
    enumFromThenTo    :: a -> a -> a -> [a]    -- [n,n'..m]

    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo

defaultEnumFromTo n m    =  takeWhile (<= m) (enumFrom n)
defaultEnumFromThenTo n n' m
            =  takeWhile (if n' >= n then (<= m) else (>= m))
                     (enumFromThen n n')
{-# defaultEnumFromTo :: Inline #-}
{-# defaultEnumFromThenTo :: Inline #-}

-- Text class

type  ReadS a = String -> [(a,String)]
type  ShowS   = String -> String

class  Text a  where
    readsPrec :: Int -> ReadS a
    showsPrec :: Int -> a -> ShowS
    readList  :: ReadS [a]
    showList  :: [a] -> ShowS

    readList    = readParen False (\r -> [pr | ("[",s)    <- lex r,
                           pr    <- readl s])
              where readl  s = [([],t)   | ("]",t)  <- lex s] ++
                   [(x:xs,u) | (x,t)    <- reads s,
                           (xs,u)   <- readl' t]
            readl' s = [([],t)   | ("]",t)  <- lex s] ++
                       [(x:xs,v) | (",",t)  <- lex s,
                           (x,u)    <- reads t,
                           (xs,v)   <- readl' u]
    showList []    = showString "[]"
    showList (x:xs)
        = showChar '[' . shows x . showl xs
          where showl []     = showChar ']'
            showl (x:xs) = showString ", " . shows x . showl xs



-- Binary class

class  Binary a  where
    readBin        :: Bin -> (a,Bin)
    showBin        :: a -> Bin -> Bin


-- Trivial type

-- data  ()  =  ()  deriving (Eq, Ord, Ix, Enum, Binary)

instance  Text ()  where
    readsPrec p    = readParen False
                            (\r -> [((),t) | ("(",s) <- lex r,
                         (")",t) <- lex s ] )
    showsPrec p () = showString "()"


-- Binary type

instance  Text Bin  where
    readsPrec p s  =  error "readsPrec{PreludeText}: Cannot read Bin."
    showsPrec p b  =  showString "<<Bin>>"


-- Boolean type

data  Bool  =  False | True  deriving (Eq, Ord, Ix, Enum, Text, Binary)
{-# ImportLispType (Bool ( False("'#f"), True("'#t"))) #-}


-- Character type

instance  Eq Char  where
    (==)        =  primEqChar
    (/=)                =  primNeqChar

instance  Ord Char  where
    (<)                 =  primLsChar
    (<=)        =  primLeChar
    (>)                 =  primGtChar
    (>=)                =  primGeChar

instance  Ix Char  where
    range (c,c')    =  [c..c']
    index b@(c,c') ci
    | inRange b ci    =  ord ci - ord c
    | otherwise    =  indexError ci c c'
    inRange (c,c') ci    =  ord c <= i && i <= ord c'
               where i = ord ci
    {-# range :: Inline #-}

instance  Enum Char  where
    enumFrom        = charEnumFrom
    enumFromThen        = charEnumFromThen
    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo
    {-# enumFrom :: Inline #-}
    {-# enumFromThen :: Inline #-}
    {-# enumFromTo :: Inline #-}
    {-# enumFromThenTo :: Inline #-}

charEnumFrom c        =  map chr [ord c .. ord maxChar]
charEnumFromThen c c'    =  map chr [ord c, ord c' .. ord lastChar]
               where lastChar = if c' < c then minChar else maxChar
{-# charEnumFrom :: Inline #-}
{-# charEnumFromThen :: Inline #-}

instance  Text Char  where
    readsPrec p      = readParen False
                            (\r -> [(c,t) | ('\'':s,t)<- lex r,
                        (c,_)     <- readLitChar s])

    showsPrec p '\'' = showString "'\\''"
    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''

    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
                           (l,_)      <- readl s ])
           where readl ('"':s)    = [("",s)]
             readl ('\\':'&':s)    = readl s
             readl s        = [(c:cs,u) | (c ,t) <- readLitChar s,
                              (cs,u) <- readl t          ]

    showList cs = showChar '"' . showl cs
         where showl ""       = showChar '"'
               showl ('"':cs) = showString "\\\"" . showl cs
               showl (c:cs)   = showLitChar c . showl cs

type  String = [Char]


-- Standard Integral types

instance  Eq Int  where
    (==)        =  primEqInt
    (/=)                =  primNeqInt

instance  Eq Integer  where
    (==)        =  primEqInteger
    (/=)                =  primNeqInteger

instance  Ord Int  where
    (<)                 =  primLsInt
    (<=)        =  primLeInt
    (>)                 =  primGtInt
    (>=)                =  primGeInt
    max                 =  primIntMax
    min                 =  primIntMin

instance  Ord Integer  where
    (<)                 =  primLsInteger
    (<=)        =  primLeInteger
    (>)                 =  primGtInteger
    (>=)                =  primGeInteger
    max                 =  primIntegerMax
    min                 =  primIntegerMin

instance  Num Int  where
    (+)            =  primPlusInt
    (-)                 =  primMinusInt
    negate        =  primNegInt
    (*)            =  primMulInt
    abs            =  primAbsInt
    signum        =  signumReal
    fromInteger        =  primIntegerToInt

instance  Num Integer  where
    (+)            =  primPlusInteger
    (-)                 =  primMinusInteger
    negate        =  primNegInteger
    (*)            =  primMulInteger
    abs            =  primAbsInteger
    signum        =  signumReal
    fromInteger x    =  x

signumReal x | x == 0     =  0
            | x > 0     =  1
         | otherwise = -1

instance  Real Int  where
    toRational x    =  toInteger x % 1

instance  Real Integer    where
    toRational x    =  x % 1

instance  Integral Int    where
    quotRem        =  primQuotRemInt
    toInteger        =  primIntToInteger

instance  Integral Integer  where
    quotRem        =  primQuotRemInteger
    toInteger x        =  x

instance  Ix Int  where
    range (m,n)        =  [m..n]
    index b@(m,n) i
    | inRange b i    =  i - m
    | otherwise    =  indexError i m n
    inRange (m,n) i    =  m <= i && i <= n
    {-# range :: Inline #-}

instance  Ix Integer  where
    range (m,n)        =  [m..n]
    index b@(m,n) i
    | inRange b i    =  fromInteger (i - m)
    | otherwise    =  indexError i m n
    inRange (m,n) i    =  m <= i && i <= n
    {-# range :: Inline #-}

instance  Enum Int  where
    enumFrom        =  numericEnumFrom
    enumFromThen    =  numericEnumFromThen
    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo
    {-# enumFrom :: Inline #-}
    {-# enumFromThen :: Inline #-}
    {-# enumFromTo :: Inline #-}
    {-# enumFromThenTo :: Inline #-}

instance  Enum Integer  where
    enumFrom        =  numericEnumFrom
    enumFromThen    =  numericEnumFromThen
    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo
    {-# enumFrom :: Inline #-}
    {-# enumFromThen :: Inline #-}
    {-# enumFromTo :: Inline #-}
    {-# enumFromThenTo :: Inline #-}

numericEnumFrom        :: (Real a) => a -> [a]
numericEnumFromThen    :: (Real a) => a -> a -> [a]
numericEnumFrom        =  iterate (+1)
numericEnumFromThen n m    =  iterate (+(m-n)) n

{-# numericEnumFrom :: Inline #-}
{-# numericEnumFromThen :: Inline #-}


instance  Text Int  where
    readsPrec p        = readSigned readDec
    showsPrec       = showSigned showInt

instance  Text Integer  where
    readsPrec p     = readSigned readDec
    showsPrec        = showSigned showInt


-- Standard Floating types

instance  Eq Float  where
    (==)        =  primEqFloat
    (/=)                =  primNeqFloat

instance  Eq Double  where
    (==)        =  primEqDouble
    (/=)                =  primNeqDouble

instance  Ord Float  where
    (<)                 =  primLsFloat
    (<=)        =  primLeFloat
    (>)                 =  primGtFloat
    (>=)                =  primGeFloat
    max                 =  primFloatMax
    min                 =  primFloatMin

instance  Ord Double  where
    (<)                 =  primLsDouble
    (<=)        =  primLeDouble
    (>)                 =  primGtDouble
    (>=)                =  primGeDouble
    max                 =  primDoubleMax
    min                 =  primDoubleMax

instance  Num Float  where
    (+)            =  primPlusFloat
    (-)                 =  primMinusFloat
    negate        =  primNegFloat
    (*)            =  primMulFloat
    abs            =  primAbsFloat
    signum        =  signumReal
    fromInteger n    =  encodeFloat n 0

instance  Num Double  where
    (+)            =  primPlusDouble
    (-)                 =  primMinusDouble
    negate        =  primNegDouble
    (*)            =  primMulDouble
    abs            =  primAbsDouble
    signum        =  signumReal
    fromInteger n    =  encodeFloat n 0

instance  Real Float  where
    toRational        =  primFloatToRational

instance  Real Double  where
    toRational        =  primDoubleToRational

-- realFloatToRational x    =  (m%1)*(b%1)^^n
--                where (m,n) = decodeFloat x
--                  b     = floatRadix  x

instance  Fractional Float  where
    (/)            =  primDivFloat
    fromRational        =  primRationalToFloat
--    fromRational    =  rationalToRealFloat

instance  Fractional Double  where
    (/)            =  primDivDouble
    fromRational        =  primRationalToDouble
--    fromRational    =  rationalToRealFloat

-- rationalToRealFloat x    = x'
--         where x'    = f e
--               f e   = if e' == e then y else f e'
--                       where y      = encodeFloat (round (x * (1%b)^^e)) e
--                             (_,e') = decodeFloat y
--               (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
--                                         / fromInteger (denominator x))
--               b     = floatRadix x'

instance  Floating Float  where
    pi            =  primPiFloat
    exp            =  primExpFloat
    log            =  primLogFloat
    sqrt        =  primSqrtFloat
    sin            =  primSinFloat
    cos            =  primCosFloat
    tan            =  primTanFloat
    asin        =  primAsinFloat
    acos        =  primAcosFloat
    atan        =  primAtanFloat
    sinh        =  primSinhFloat
    cosh        =  primCoshFloat
    tanh        =  primTanhFloat
    asinh        =  primAsinhFloat
    acosh        =  primAcoshFloat
    atanh        =  primAtanhFloat

instance  Floating Double  where
    pi            =  primPiDouble
    exp            =  primExpDouble
    log            =  primLogDouble
    sqrt        =  primSqrtDouble
    sin            =  primSinDouble
    cos            =  primCosDouble
    tan            =  primTanDouble
    asin        =  primAsinDouble
    acos        =  primAcosDouble
    atan        =  primAtanDouble
    sinh        =  primSinhDouble
    cosh        =  primCoshDouble
    tanh        =  primTanhDouble
    asinh        =  primAsinhDouble
    acosh        =  primAcoshDouble
    atanh        =  primAtanhDouble


instance  RealFrac Float  where
    properFraction    =  floatProperFraction

instance  RealFrac Double  where
    properFraction    =  floatProperFraction

floatProperFraction x
    | n >= 0    =  (fromInteger m * fromInteger b ^ n, 0)
    | otherwise    =  (fromInteger w, encodeFloat r n)
            where (m,n) = decodeFloat x
                  b     = floatRadix x
                  (w,r) = quotRem m (b^(-n))

instance  RealFloat Float  where
    floatRadix _    =  primFloatRadix
    floatDigits _    =  primFloatDigits
    floatRange _    =  (primFloatMinExp,primFloatMaxExp)
    decodeFloat        =  primDecodeFloat
    encodeFloat        =  primEncodeFloat
    atan2               =  primAtan2Float

instance  RealFloat Double  where
    floatRadix _    =  primDoubleRadix
    floatDigits    _    =  primDoubleDigits
    floatRange _    =  (primDoubleMinExp,primDoubleMaxExp)
    decodeFloat        =  primDecodeDouble
    encodeFloat        =  primEncodeDouble
    atan2               =  primAtan2Double

instance  Enum Float  where
    enumFrom        =  numericEnumFrom
    enumFromThen    =  numericEnumFromThen
    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo
    {-# enumFrom :: Inline #-}
    {-# enumFromThen :: Inline #-}
    {-# enumFromTo :: Inline #-}
    {-# enumFromThenTo :: Inline #-}

instance  Enum Double  where
    enumFrom        =  numericEnumFrom
    enumFromThen    =  numericEnumFromThen
    enumFromTo          = defaultEnumFromTo
    enumFromThenTo      = defaultEnumFromThenTo
    {-# enumFrom :: Inline #-}
    {-# enumFromThen :: Inline #-}
    {-# enumFromTo :: Inline #-}
    {-# enumFromThenTo :: Inline #-}

instance  Text Float  where
    readsPrec p        = readSigned readFloat
    showsPrec       = showSigned showFloat

instance  Text Double  where
    readsPrec p        = readSigned readFloat
    showsPrec       = showSigned showFloat


-- Lists

-- data  [a]  =  [] | a : [a]  deriving (Eq, Ord, Binary)

instance  (Text a) => Text [a]  where
    readsPrec p        = readList
    showsPrec p        = showList

-- Functions

instance  Text (a -> b)  where
    readsPrec p s  =  error "readsPrec{PreludeCore}: Cannot read functions."
    showsPrec p f  =  showString "<<function>>"

-- Support for class Bin

instance Binary Int where
  showBin i b = primShowBinInt i b
  readBin b = primReadBinInt b

instance Binary Integer where
  showBin i b = primShowBinInteger i b
  readBin b = primReadBinInteger b

instance Binary Float where
  showBin f b = primShowBinFloat f b
  readBin b = primReadBinFloat b

instance Binary Double where
  showBin d b = primShowBinDouble d b
  readBin b = primReadBinDouble b

instance Binary Char where
  showBin c b = primShowBinInt (ord c) b
  readBin b = (chr i,b') where
     (i,b') = primReadBinSmallInt b primMaxChar

instance (Binary a) => Binary [a]  where
    showBin l b = showBin (length l :: Int) (sb1 l b) where
      sb1 [] b = b
      sb1 (h:t) b = showBin h (sb1 t b)
    readBin bin = rbl len bin' where
       len :: Int
       (len,bin') = readBin bin
       rbl 0 b = ([],b)
       rbl n b = (h:t,b'') where
         (h,b') = readBin b
         (t,b'') = rbl (n-1) b'

instance  (Ix a, Binary a, Binary b) => Binary (Array a b)  where
    showBin a = showBin (bounds a) . showBin (elems a)
    readBin bin = (listArray b vs, bin'')
         where (b,bin')   = readBin bin
               (vs,bin'') = readBin bin'